home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / McCartney-library 1.1 / CODE / file-utils / docs-menu.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  2.8 KB  |  83 lines  |  [TEXT/CCL2]
  1. ;;; docs-menu.lisp
  2. ;;;
  3. ;;; Paul McCartney, Spring 1992
  4. ;;;
  5. ;;; Copyright © 1992 Paul McCartney.  All Rights Reserved.
  6. ;;; 
  7. ;;; Washington University Medical Informatics Training Program
  8. ;;;
  9. ;;; DESCRIPTION:
  10. ;;;
  11. ;;; docs-menu (short for "Documents Menu") is a menu that lists all
  12. ;;; files matching a certain pattern.  The files can be quickly opened
  13. ;;; by choosing it from the docs menu.  The idea is to minimize the use
  14. ;;; of the open file dialog, saving time.
  15. ;;;
  16. ;;; USE:
  17. ;;;
  18. ;;; initialize-menu-tools  - initialization
  19. ;;; *menu-item-separator*  - globally bound menu item of a menu separator
  20. ;;; make-docs-menu         - create the docs menu given a list of directories
  21. ;;;                          and file patterns
  22. ;;;
  23. ;;; HISTORY:
  24. ;;;
  25. ;;; 7/12/90 Created.  - PM
  26. ;;; 4/10/92 Updated to MCL 2.0.  - PM
  27. ;;;
  28.  
  29. (in-package :ccl)
  30.  
  31. (eval-when (:compile-toplevel :load-toplevel :execute)
  32.   (export '(initialize-menu-tools *menu-item-separator* make-docs-menu)))
  33.  
  34.  
  35. ;;; This is a global menu item that is a separator between menu
  36. ;;; items in a menu.
  37. ;;;
  38. (defvar *menu-item-separator*)
  39.  
  40.  
  41. (defun initialize-menu-tools ()
  42.   (setf *menu-item-separator*
  43.         (make-instance 'menu-item :menu-item-title "-")))
  44.   
  45.  
  46. ;;; This creates a menu containing a list of directory menus and possibly
  47. ;;; separators.  Each directory menu contains the name of a file matching
  48. ;;; a pattern in the directory.  When the name of a file is selected from
  49. ;;; the menu, the file is opened for editing.
  50. ;;;
  51. ;;; dirs-and-patterns is a list.  Each element of the list is either a
  52. ;;; (list <directory> <pattern>) or a non-list.  Non-list elements are
  53. ;;; assumed to denote a menu item separator.
  54. ;;;
  55. (defun make-docs-menu (name dirs-and-patterns)
  56.   (let ((sub-menus ()))
  57.     (dolist (dir-and-pattern dirs-and-patterns (make-instance 'menu
  58.                                                 :menu-title name
  59.                                                 :menu-items (nreverse sub-menus)))
  60.       (if (listp dir-and-pattern)
  61.         (push (make-docs-menu-item (first dir-and-pattern) (second dir-and-pattern))
  62.               sub-menus)
  63.         (push *menu-item-separator* sub-menus))) ))
  64.       
  65.  
  66. ;;; This creates a single directory menu containing as menu items the files
  67. ;;; in a directory that match a certain pattern.  When the menu item is
  68. ;;; selected, the file is open for editing.
  69. ;;;
  70. (defun make-docs-menu-item (dir pattern)
  71.   (let ((l ())
  72.         (file-pattern (concatenate 'simple-string dir pattern)))
  73.     (dolist (file 
  74.              (directory file-pattern :test #'(lambda (x) (equal (mac-file-type x) :text)))
  75.              (make-instance 'menu :menu-title dir :menu-items (nreverse l)))
  76.       (push (make-instance 'menu-item
  77.               :menu-item-title (file-namestring file)
  78.               :menu-item-action (eval `(function (lambda () (ed ,file)))))
  79.             l)) ))
  80.         
  81.  
  82. (provide :docs-menu)
  83.